home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE16 / CONSTRUC / EXPERT.PAS next >
Encoding:
Pascal/Delphi Source File  |  1996-11-07  |  2.9 KB  |  106 lines
  1. program Expert;
  2. {$APPTYPE CONSOLE}
  3. uses
  4.   Facts, Rules, Controls, Dialogs;
  5.  
  6.   function Forwards: Integer;
  7.   var
  8.     RulesFired,i: Integer;
  9.   begin
  10.     Result := 0;
  11.     RulesFired := NumRule;
  12.     _Fact[5].Value := Yes; { start }
  13.     while (Result = 0) and (RulesFired > 0) do
  14.     begin
  15.       RulesFired := 0;
  16.       for i:=1 to RuleMax do { all rules }
  17.       begin
  18.         if TestRule(i) then
  19.         begin
  20.           FireRule(i);
  21.           Inc(RulesFired)
  22.         end
  23.       end;
  24.       Result := NumFact;
  25.       while (Result > 0) and
  26.             ((not _Fact[Result].Goal) or
  27.              ((_Fact[Result].Goal) and
  28.               (_Fact[Result].Value = UnKnown))) do Dec(Result)
  29.     end
  30.   end {Forwards};
  31.  
  32.   procedure Backwards(Goal: Integer);
  33.   Const Depth: Word = 0;
  34.   var i,j: Integer;
  35.   begin
  36.     Inc(Depth);
  37.     writeln(' ':Depth,Goal);
  38.     i := 1;
  39.     while i <= RuleMax do { all rules }
  40.     begin
  41.       if Conclude(i,Goal) then
  42.       begin
  43.         if TestRule(i) then FireRule(i)
  44.         else { infer or ask }
  45.         begin
  46.           j := 1;
  47.           while j <= NumRule do
  48.           begin
  49.             if (_Rule[j].Rule = i) and (_Rule[j].CF = 0) and
  50.                (_Fact[_Rule[j].Fact].Value = UnKnown) then
  51.             begin
  52.               Backwards(_Rule[j].Fact); { infer }
  53.               if TestRule(i) then j := NumRule
  54.               else { ask }
  55.               begin
  56.                 if _Fact[_Rule[j].Fact].Question <> '' then
  57.                 begin
  58.                   writeln(' ':Depth,_Fact[_Rule[j].Fact].Question);
  59.                   if MessageDlg(_Fact[_Rule[j].Fact].Question,
  60.                                  mtConfirmation,[mbYes,mbNo],0) = mrYes then
  61.                     _Fact[_Rule[j].Fact].Value := Yes
  62.                   else
  63.                   begin
  64.                     _Fact[_Rule[j].Fact].Value := No; { can never prove }
  65.                     j := NumRule
  66.                   end
  67.                 end;
  68.                 if TestRule(i) then j := NumRule
  69.               end
  70.             end;
  71.             Inc(j)
  72.           end;
  73.           if TestRule(i) then
  74.           begin
  75.             FireRule(i);
  76.             i := RuleMax
  77.           end;
  78.         end
  79.       end;
  80.       Inc(i)
  81.     end;
  82.     Dec(Depth)
  83.   end {Backwards};
  84.  
  85. var
  86.   Goal: Integer;
  87. begin
  88.   writeln(NumFact,': facts');
  89.   writeln(NumRule,': rules');
  90.   Goal := Forwards;
  91.   if (Goal > 0) and _Fact[Goal].Goal and (_Fact[Goal].Value <> UnKnown) then
  92.   begin
  93.     writeln('Forward chaining: ');
  94.     writeln(_Fact[Goal].Name);
  95.     writeln(ValueStr[_Fact[Goal].Value])
  96.   end;
  97.   writeln;
  98.   for Goal:=1 to NumFact do _Fact[Goal].Value := UnKnown;
  99.   for Goal:=1 to NumRule do _Rule[Goal].Fired := False;
  100.   Goal := 1;
  101.   Backwards(Goal);
  102.   writeln('Backwards chaining: ');
  103.   writeln(_Fact[Goal].Name);
  104.   writeln(ValueStr[_Fact[Goal].Value]);
  105.   for Goal:=2 to NumFact do writeln(_Fact[Goal].Name,' => ',ValueStr[_Fact[Goal].Value])
  106. end.